!/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!*  Copyleft (!c) 2004-2005 Div. Nucl. Med., Cyric, Tohoku Univ.    *
!*  Copyleft (!c) 2005-2011 Elseif Laboratory.                      *
!*  elseifkk@users.sf.net                                           *
!*                                                                  *
!*  All Rights Reversed.                                            *
!*                                                                  *
!*                                                                  *
!*  LICENSE AGREEMENT:                                              *
!*                                                                  *
!*  You agree that we don't agree to anything.                      *
!*                                                                  *
!*                                                                  *
!*  DISCLAIMER OF WARRANTIES:                                       *
!*                                                                  *
!*  This software is provided to you "AS IS," and the authors and   *
!*  contributors disclaim any warranty or liability obligations to  *
!*  you of any kind, implied or express, including but not limited  *
!*  to the warranties of merchantability, fitness for a particular  *
!*  purpose, and non-infringement.                                  *
!* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
!
! data conversion (for human) utility.
! 
! TTD:
!   none.
! note:
!   1) most of them were written in asm as cutyA.asm.
!
module cuty
  implicit none
  integer*4,external::b2d
  integer*4,external::w2d
  integer*4,external::d2str
  integer*4,external::d2hexstr
  external::f2str_s ! twin of f2str_f
  integer*4,external::f2str_fx ! same
  interface f2str
     module procedure f2str_c
     integer*4 function f2str_f(x,str,opt)
       real*8,intent(in)::x
       character*(*),intent(out)::str
       integer*4,intent(in),optional::opt
     end function f2str_f
     module procedure ff2str_c
  end interface
  interface conc
     module procedure concs
     module procedure concd
     module procedure concf
     module procedure concf4
     module procedure concw
     module procedure concx
  end interface
  external swap_words,swap_word
  external swap_dwords,swap_dword
  external swap_qwords,swap_qword
  integer*4, parameter :: D2S_INPUT_BYTE = 1
  integer*4, parameter :: D2S_INPUT_WORD = 2
  integer*4, parameter :: FP2A_TRIM_TRAILING_ZEROS        =  Z'0000100'
  integer*4, parameter :: FP2A_ALLOW_INTEGER_EXPRESSION   =  Z'0000200'
  integer*4, parameter :: FP2A_ALLOW_ORDINARY_EXPRESSION  =  Z'0000400'
  integer*4, parameter :: FP2A_FORCE_NOT_SHOW_EXPSIGN     =  Z'0000800'
  integer*4, parameter :: FP2A_FORCE_SHOW_SIGN            =  Z'0001000'
  integer*4, parameter :: FP2A_KEEP_LEADING_ZEROS         =  Z'0002000'
  integer*4, parameter :: FP2A_ALLOW_ENGINEERING_NOTATION =  Z'0004000'
  integer*4, parameter :: FP2A_INPUT_REAL10               =  Z'0008000'
  integer*4, parameter :: FP2A_SUPRESS_E0                 =  Z'0010000'
  integer*4, parameter :: FP2A_NULLTERM                   =  Z'0020000'
  integer*4, parameter :: FP2A_TRIM_ALL_TRAILING_ZEROS    =  Z'0040000'
  integer*4, parameter :: FP2A_ADJUSTR                    =  Z'0080000'
  integer*4, parameter :: FP2A_INPUT_REAL4                =  Z'0100000'
  integer*4, parameter :: FP2A_MAXIMUM_DIGIT = 18
  integer*4, parameter :: FP2A_MINIMUM_DIGIT = 3
  integer*4, parameter :: FP2A_DEFAULT=ior(8,&
       & ior(FP2A_ALLOW_ORDINARY_EXPRESSION,&
       & ior(FP2A_FORCE_NOT_SHOW_EXPSIGN,&
       & ior(FP2A_SUPRESS_E0,&
       &     FP2A_TRIM_TRAILING_ZEROS))))
  integer*4, parameter::KIND_REAL4 = 32
  integer*4, parameter::KIND_REAL8 = 64
  integer*4, parameter::KIND_INTEGER1 = 1
  integer*4, parameter::KIND_INTEGER2 = 2
  integer*4, parameter::KIND_INTEGER4 = 4
contains 
  function f2str_c(x,opt)
    character*(128) f2str_c
    real*8,intent(in)::x
    integer*4,intent(in),optional::opt
    integer*4 m
    if(present(opt)) then
       m=opt
    else
       m=FP2A_DEFAULT
    endif
    call f2str_s(x,f2str_c,m)
  end function f2str_c
  !
  integer*4 function ff2str_c(x,str,opt,del)
    real*8,intent(in)::x(:)
    character*(*),intent(out)::str
    integer*4,intent(in),optional::opt
    character*1,intent(in),optional::del
    character*32 buf
    integer*4 i,k,l,lmax,m
    character*1 d
    if(present(opt)) then
       m=opt
    else
       m=FP2A_DEFAULT
    endif
    if(present(del)) then
       d=del
    else
       d=" "
    endif
    lmax=len(str)
    l=1
    do i=1,size(x)
       k=f2str_f(x(i),buf,m)
       if(i/=size(x)) then
          k=k+1
          buf(k:k)=d
       endif
       if(l+k>lmax) exit
       str(l:)=buf(1:k)
       l=l+k
    end do
    ff2str_c=l
  end function ff2str_c
  !
  integer*4 function concs(p,l,s)
    character*(*),intent(inout)::p
    integer*4,intent(in)::l
    character*(*),intent(in)::s
    integer*4 ll
    ll=len(s)
    p(l:l+ll)=s(1:ll)
    concs=l+ll
  end function concs
  integer*4 function concd(p,l,d,hex)
    character*(*),intent(inout)::p
    integer*4,intent(in)::l
    integer*4,intent(in)::d
    integer*4,intent(in),optional::hex
    character*32 buf
    integer*4 ll
    if(.not.present(hex))then
       ll=d2str(d,buf)
    else
       ll=d2hexstr(d,buf)
    endif
    p(l:l+ll)=buf(1:ll)
    concd=l+ll
  end function concd
  integer*4 function concw(p,l,w)
    character*(*),intent(inout)::p
    integer*4,intent(in)::l
    integer*2,intent(in)::w
    integer*4 d
    d=w
    concw=concd(p,l,d)
  end function concw
  integer*4 function concf(p,l,x)
    character*(*),intent(inout)::p
    integer*4,intent(in)::l
    real*8,intent(in)::x
    character*32 buf
    integer*4 ll
    ll=f2str(x,buf)
    p(l:l+ll)=buf(1:ll)
    concf=l+ll
  end function concf
  integer*4 function concf4(p,l,s)
    character*(*),intent(inout)::p
    integer*4,intent(in)::l
    real*4,intent(in)::s
    real*8 x  
    x=s
    concf4=concf(p,l,x)
  end function concf4
  integer*4 function concx(p,l,b,d)
    character*(*),intent(inout)::p
    integer*4,intent(in)::l
    integer*1,intent(in)::b
    integer*4,intent(in)::d
    character*32 buf
    integer*4 ll
    select case(d)
    case(KIND_INTEGER1)
       ll=d2str(b2d(b),buf)
    case(KIND_INTEGER2)
       ll=d2str(w2d(b),buf)
    case(KIND_INTEGER4)
       ll=d2str(b,buf)
    case(KIND_REAL4)
       ll=f2str_fx(b,buf,IOR(FP2A_DEFAULT, FP2A_INPUT_REAL4))
    case(KIND_REAL8)
       ll=f2str_fx(b,buf)
    case default
       buf='?'
       ll=1
    end select
    p(l:l+ll)=buf(1:ll)
    concx=l+ll
  end function concx
end module cuty
